###
 substandard lisp: an implementation of Standard Lisp.
    Copyright (C) 2011 Nicky Nickell

    substandard lisp is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program.  If not, see <http://www.gnu.org/licenses/>.
###
`
#define APPLY1(fn, x) new lisp_pair(fn, new lisp_pair(x, NIL))
#define APPLYN(fn, x) new lisp_pair(fn, x)
#define QUOTE(x) APPLY1(new lisp_id('quote', env.oblist), x)
#define FUNCTION(x) APPLY1(new lisp_id('function', env.oblist), x)
#define BACKQUOTE(x) APPLY1(new lisp_id('backquote', env.oblist), x)
#define UNQUOTE(x) APPLY1(new lisp_id('unquote', env.oblist), x)
#define UNQUOTEL(x) APPLY1(new lisp_id('unquotel', env.oblist), x)
`

FTYPE_EXPR = 0
FTYPE_FEXPR = 1
FTYPE_MACRO = 2

ERROR_RETURN = 0
ERROR_GO = 1
ERROR_INTERNAL = 2
ERROR_USER = 3

CHANNEL_INPUT = 0
CHANNEL_OUTPUT = 1

TYPE_INTEGER = parseInt '00000001', 2
TYPE_FLOATING = parseInt '00000010', 2
TYPE_ID = parseInt '00000100', 2
TYPE_STRING = parseInt '00001000', 2
TYPE_PAIR = parseInt '00010000', 2
TYPE_VECTOR = parseInt '00100000', 2
TYPE_FUNCTION = parseInt '01000000', 2
TYPE_BOOLEAN = parseInt '10000000', 2
TYPE_UNDEFINED = parseInt '100000000', 2
TYPE_CHANNEL = parseInt '1000000000', 2
TYPE_JS_OBJ = parseInt '10000000000', 2
TYPE_JS_FUNC = parseInt '100000000000', 2 

CLASS_FTYPE = TYPE_ID
CLASS_NUMBER = TYPE_INTEGER | TYPE_FLOATING
CLASS_CONSTANT = CLASS_NUMBER | TYPE_STRING | TYPE_VECTOR | TYPE_FUNCTION
CLASS_ANY = CLASS_CONSTANT | TYPE_ID | TYPE_PAIR | TYPE_BOOLEAN | TYPE_UNDEFINED | TYPE_CHANNEL | TYPE_JS_OBJ | TYPE_JS_FUNC
CLASS_EBOOLEAN = CLASS_ANY
CLASS_ATOM = CLASS_ANY ^ TYPE_PAIR
CLASS_JS = TYPE_JS_OBJ | TYPE_JS_FUNC

ftype_strings = {}
ftype_strings[FTYPE_EXPR] = 'expr'
ftype_strings[FTYPE_FEXPR] = 'fexpr'
ftype_strings[FTYPE_MACRO] = 'macro'

type_strings = {}
type_strings[TYPE_INTEGER] = 'integer'
type_strings[TYPE_FLOATING] = 'floating'
type_strings[TYPE_ID] = 'id'
type_strings[TYPE_STRING] = 'string'
type_strings[TYPE_PAIR] = 'pair'
type_strings[TYPE_VECTOR] = 'vector'
type_strings[TYPE_FUNCTION] = 'function'
type_strings[TYPE_BOOLEAN] = 'boolean'
type_strings[TYPE_UNDEFINED] = 'undefined'
type_strings[TYPE_CHANNEL] = 'channel'
type_strings[TYPE_JS_OBJ] = 'js-obj'
type_strings[TYPE_JS_FUNC] = 'js-func'

class_strings = {}
class_strings[CLASS_NUMBER] = 'number'
class_strings[CLASS_CONSTANT] = 'constant'
class_strings[CLASS_ANY] = 'any'
class_strings[CLASS_ATOM] = 'atom'

builtins = {}
interpreted_builtins = {}
lisp_docs = {}
lisp_arg_info = {}

class lisp_object
  constructor: (@type, @value) ->
    @constant = false

  evaluate: (env) ->
    return this

  prin1: ->
    return String @value
    
  prin2: ->
    return String @value

class lisp_integer extends lisp_object
  constructor: (value) ->
    super TYPE_INTEGER, BigInteger value
    @prin2 = @prin1

  prin1: ->
    return @value.toString()
    
class lisp_floating extends lisp_object
  constructor: (value) ->
    super TYPE_FLOATING, Number value
    @prin2 = @prin1

  prin1: ->
    return String @value

class lisp_id extends lisp_object
  constructor: (name, oblist) ->
    name = name.replace '!', ''
    if oblist isnt undefined and oblist[name] isnt undefined
      return oblist[name]
    super TYPE_ID, name
    @proplist = {}
    @flags = {}
    if oblist isnt undefined
      oblist[name] = this
    @prin2 = @prin1

  evaluate: (env) ->
    return env.variables.get @value

  prin1: ->
    return @value
      
class lisp_string extends lisp_object
  constructor: (str) ->
    if /^".*"$/.test(str)
      str = eval str
    super TYPE_STRING, str

  prin1: ->
    return "\"#{ @value }\""

  prin2: ->
    return @value
    
class lisp_vector extends lisp_object
  constructor: (vect) ->
    super TYPE_VECTOR, vect

  prin1: ->
    ret = []
    for e in @value
      ret.push e.prin1()
    return "[#{ ret.join ' ' }]"

  prin2: ->
    ret = []
    for e in @value
      ret.push e.prin2()
    return "[#{ ret.join ' ' }]"
    
    
class lisp_pair extends lisp_object
  constructor: (@car, @cdr) ->
    super TYPE_PAIR

  evaluate: (env) ->
    switch @car.type
      when TYPE_PAIR
        func = @car.evaluate env
      when TYPE_FUNCTION
        func = @car
      else
        func = env.functions.get @car.value
        if func is UNDEFINED
          func = env.variables.get @car.value
        if func is UNDEFINED
          throw new lisp_error ERROR_INTERNAL, T, "undefined function #{ @car.value }"
          
    if func.type isnt TYPE_FUNCTION
      throw new lisp_error ERROR_INTERNAL, T, 'not a function'

    arguments = list_to_array @cdr
      
    if not func.arity_check arguments.length
      throw new lisp_error ERROR_INTERNAL, T, "improper number of arguments for #{ func.prin1() }"
      
    if func.ftype is FTYPE_EXPR
      for i in [0...arguments.length]
        arguments[i] = arguments[i].evaluate env
        
    if not func.interpreted
      for i in [0...func.constant_args]
        if not type_check arguments[i].type, func.argument_masks[i]
          throw new lisp_error ERROR_INTERNAL, T, "#{ arguments[i].prin1() } NOT #{ mask_to_string func.argument_masks[i] } FOR #{ func.prin1() }"
          
          
      if func.rest_arg
        for i in [func.constant_args...arguments.length]
          if not type_check arguments[i].type, func.argument_masks[func.constant_args]
            throw new lisp_error ERROR_INTERNAL, T, "#{ arguments[i].prin1() } NOT #{ mask_to_string func.argument_masks[func.argument_masks.length - 1] } FOR #{ func.prin1() }"

    if func.ftype is FTYPE_MACRO
      arguments.unshift @car

    arguments = func.parse_args arguments
    return_value = func.value arguments, env
    
    if func.ftype is FTYPE_MACRO
      return_value = return_value.evaluate env
      
    return return_value

  prin1: ->
    tmp = []
    p = this
    loop
      tmp.push p.car.prin1()
      if p.cdr is NIL
        break
      else if not (p.cdr.type & TYPE_PAIR)
        tmp.push '.'
        tmp.push p.cdr.prin1()
        break
      p = p.cdr
    return "(#{ tmp.join ' ' })"

  prin2: ->
    tmp = []
    p = this
    loop
      tmp.push p.car.prin2()
      if p.cdr is NIL
        break
      else if not (p.cdr.type & TYPE_PAIR)
        tmp.push '.'
        tmp.push p.cdr.prin2()
        break
      p = p.cdr
    return "(#{ tmp.join ' ' })"

class lisp_bool extends lisp_object
  constructor: (value) ->
    super TYPE_BOOLEAN, value
    @car = this
    @cdr = this
    @prin2 = @prin1

  prin1: ->
    if @value is true
      return 'T'
    else
      return 'NIL'
    
T = new lisp_bool true
NIL = new lisp_bool false
UNDEFINED = new lisp_object TYPE_UNDEFINED, undefined
EOFC = unescape '%04'
EOF = new lisp_string EOFC
    
class lisp_function extends lisp_object
  constructor: (method, @constant_args, @optional_args, @rest_arg, @argument_masks, @ftype) ->
    super TYPE_FUNCTION, method
    @interpreted = false
    
  parse_args: ->
  
  arity_check: (arglen) ->
    if @rest_arg
      return @constant_args <= arglen
    else
      return @constant_args <= arglen and arglen <= (@constant_args + @optional_args)
      
class builtin_function extends lisp_function
  constructor: (method, arity, rest, argument_masks, ftype) ->
    super method, arity, 0, rest, argument_masks, ftype
    @prin2 = @prin1

  prin1: ->
    return "#<BUILTIN:#{ @value.name }>"
  
  parse_args: (a) ->
    ret = []
    ret.push a[i] for i in [0...@constant_args]
    if @rest_arg
      rest = []
      rest.push a[i] for i in [@constant_args...a.length]
      ret.push rest
    return ret
    
class interpreted_function extends lisp_function
  constructor: (@expression, @arguments, ftype) ->
    constant_args = 0
    optional_args = 0
    rest_arg = false
    args = []
    p = arguments
    while p isnt NIL
      if p.car.value is '&optional' or p.car.value == '&rest'
        break
      else
        args.push p.car.value
        constant_args++
      p = p.cdr

    if p.car.value is '&optional'
      p = p.cdr
      while p isnt NIL
        if p.car.value is '&rest'
          break
        else
          args.push p.car.value
          optional_args++
        p = p.cdr
          
    if p.car.value is '&rest'
      p = p.cdr
      args.push p.car.value
      rest_arg = true
      
    method = (a, env) ->
      result = NIL
      err = UNDEFINED
      env.variables = env.variables.inner_block()
      for i in [0...a.length]
        env.variables._set args[i], a[i]
        
      try
        result = @expression.evaluate env
      catch e
        err = e
      finally
        env.variables = env.variables.outer
        if err isnt UNDEFINED
          throw err
        else
          return result
          
    super method, constant_args, optional_args, rest_arg, [], ftype
    @interpreted = true
    @prin2 = @prin1

  prin1: ->
    return "#<LAMBDA: #{ @arguments.prin1() } #{ @expression.prin1() }>"

  parse_args: (a) ->
    ret = []
    total = @constant_args + @optional_args
    for i in [0...total]
      if a[i] isnt undefined
        ret.push a[i]
      else
        ret.push NIL
        
    if @rest_arg
      if a.length > total
        rest = []
        for i in [total...a.length]
          rest.push a[i]
        ret.push array_to_list rest
      else
        ret.push NIL

    return ret

class interpreted_fexpr extends interpreted_function
  constructor: (expression, arguments) ->
    super expression, arguments, FTYPE_FEXPR
    @constant_args = 0
    @optional_args = 0
    @rest_arg = true

class interpreted_macro extends interpreted_function
  constructor: (expression, arguments) ->
    super expression, arguments, FTYPE_MACRO
    @constant_args = 0
    @optional_args = 0
    @rest_arg = true


class lisp_channel extends lisp_object
  constructor: (data = '', @mode = CHANNEL_INPUT | CHANNEL_OUTPUT, @name) ->
    @buffer = data
    @token_back_buffer = ''
    super TYPE_CHANNEL
    @prin2 = @prin1

  prin1: ->
    return "#STREAM(#{ @name })"

  readtoken: ->
    if @token_back_buffer isnt ''
      ret = @token_back_buffer
      @token_back_buffer = ''
      return ret

    @gobble_space()
    loop
      m = @buffer.match /^("(?:[^\\"]|\\.)*"|%.*|\[|\]|[('`)]|#'|,@|,|(!.|[^\s\]\[('#,"%)]){1,})|((.|\n)*)$/g

      @buffer = if m[1] is undefined then '' else m[1]
      if m[0].charAt(0) is '%'
        @gobble_space()
        continue

      return if m[0] is '' then EOFC else m[0]
                     
  unreadtoken: (tok) ->
    @token_back_buffer = tok

  gobble_space: ->
    @buffer = @buffer.replace /^\s*|\n/, ''

  read: (env, eof_disallowed = true) ->
    t = @readtoken()
    if t is EOFC
      if eof_disallowed is true
        return EOF
      else
        throw new lisp_error ERROR_INTERNAL, T, 'unexpected EOF'

    switch t
      when '('
        next = @readtoken()
        if next is ')'
          return NIL
        @unreadtoken next

        head = new lisp_pair @read(env), NIL
        ptr = head

        next = @readtoken()
        while next isnt ')'
          if next is '.'
            ptr.cdr = @read(env)
            @readtoken()
            break
          @unreadtoken next
          ptr.cdr = new lisp_pair @read(env, false), NIL
          ptr = ptr.cdr
          next = @readtoken()
        return head;
      when ')'
        throw new lisp_error ERROR_INTERNAL, T, "unexpected token ')'"
      when '['
        vect = []
        loop
          next = @readtoken()
          if next is ']'
            break
          @unreadtoken next
          vect.push @read(env, false)
        return new lisp_vector vect

      when ']'
        throw new lisp_error ERROR_INTERNAL, T, "unexpected token ']'"
      when '\''
        return QUOTE @read(env)
      when '#\''
        return FUNCTION @read(env)
      when '`'
        return BACKQUOTE @read(env)
      when ','
        return UNQUOTE @read(env)
      when ',@'
        return UNQUOTEL @read(env)
      else
        if t.toLowerCase() is 't'
          return T
        else if t.toLowerCase() is 'nil'
          return NIL
        else if isNaN t
          if /".*"/.test t
            return new lisp_string t
          else
            return new lisp_id t, env.oblist
        else
          if /\d*\.\d*/.test t
            return new lisp_floating t
          else
            return new lisp_integer t

  readline: ->
    ret = ''
    loop
      c = @readch()
      if c is EOFC or c is '\n'
        break
      else
        ret += c
    return ret

  readch: ->
    if @buffer is ''
      return EOFC
      
    chr = this.buffer.charAt 0
    @buffer = @buffer.substr 1
    return chr
    
  write: (data) ->
    @buffer += data
    
  flush: ->
    buf = @buffer
    @buffer = ''
    return buf
    
class lisp_js_obj extends lisp_object
  constructor: (obj) ->
    super TYPE_JS_OBJ, obj
    @prin2 = @prin1
    
  prin1: ->
    return "#JS-OBJ(#{@value.constructor.name})"

class lisp_js_func extends lisp_object
  constructor: (func, @scope = null) ->
    super TYPE_JS_FUNC, func
    @prin2 = @prin1
    
    if @scope is null
      if typeof window isnt 'undefined'
        @scope = window
      else if typeof global isnt 'undefined'
        @scope = global
    
  prin1: ->
    return "#JS-FUNC(#{@value.name})"
    
class lisp_error
  constructor: (@type, @value, mess = "") ->
    if mess.type isnt TYPE_STRING
      @mess = new lisp_string mess
    else
      @mess = mess
    
    
type_check = (type, mask) ->
  return Boolean type & mask
  
homogenize_args = (a) ->
  floating = false
  integer = false
  for i in [0...a.length]
    if a[i].type is TYPE_FLOATING
      floating = true
    else
      integer = true
      
  if floating and integer
    ret = []
    for i in [0...a.length]
      if a[i].type is TYPE_INTEGER
        ret.push new lisp_floating a[i].value.toJSValue()
      else
        ret.push a[i]
    return ret
  else
    return a
    
mask_to_string = (mask) ->
  if class_strings[mask] isnt undefined
    return class_strings[mask]
  else
    set = []
    for s of type_strings
      if s & mask
        set.push type_strings[s]
    if set.length > 1
      return '{' + set.join(', ') + '}'
    else
      return set[0]

array_to_list = (arr) ->
  head = new lisp_pair arr.shift(), NIL
  ptr = head
  for i in [0...arr.length]
    if arr[i] is '.'
      ptr.cdr = arr[++i]
      break
    ptr.cdr = new lisp_pair arr[i], NIL
    ptr = ptr.cdr
  return head

list_to_array = (lis) ->
  ret = []
  p = lis
  while p isnt NIL
    ret.push p.car
    p = p.cdr
  return ret
  
lisp_to_js = (obj) ->
  switch obj.type
    when TYPE_PAIR
      return (lisp_to_js e for e in list_to_array obj)
    when TYPE_VECTOR
      return (lisp_to_js e for e in obj.value)
    else
      return obj.value
      
js_to_lisp = (obj) ->
  switch typeof obj
    when 'boolean'
      return new lisp_bool obj
    when 'string'
      return new lisp_string obj
    when 'number'
      if obj % 1 is 0
        return new lisp_integer obj
      else
        return new lisp_floating obj
    when 'object'
      if obj.constructor isnt undefined
        if obj.constructor.name is 'Array'
          return new lisp_vector (js_to_lisp e for e in obj)
        else
          return new lisp_js_obj obj
      else
        return NIL
    when 'function'
      return new lisp_js_func obj
    else
      return NIL
  
class namespace
  constructor: (up) ->
    @outer = up
    @dict = {}
    
  get: (key) ->
    if @dict[key] isnt undefined
      return @dict[key]
    else
      if @outer isnt undefined
        return @outer.get key
      else
        return UNDEFINED
        
  set: (key, value, constant = false) ->
    if @dict[key] isnt undefined
      if @dict[key].constant is true
        throw new lisp_error ERROR_INTERNAL, T, 'cannot change the value of constant: ' + key
      else
        @dict[key] = value
    else
      if @outer isnt undefined
        @outer.set key, value, constant
      else
        @._set key, value, constant
        
  _set: (key, value, constant = false) ->
    value.constant = constant
    @dict[key] = value
    
  inner_block: ->
    return new namespace this
      
class interpreter
  constructor: (@stdin = new lisp_channel(), @stdout = new lisp_channel(), @stderr = new lisp_channel()) ->
    
  evaluate: (expr) ->
    @stdin.flush()
    @stdin.write(expr)
    try
      @toploop.evaluate @environment
    catch e
      errout = @variables.get 'ERROUT*'
      switch e.type
        when ERROR_GO
          errout.write '***** GO out of context'
          @variables.set 'EMSG*', new lisp_string '***** GO out of context'
        when ERROR_RETURN
          errout.write '***** RETURN out of context'
          @variables.set 'EMSG*', new lisp_string '***** RETURN out of context'
        else
          errout.write e.message
          @variables.set 'EMSG*', new lisp_string e.message
          
  evaluate_string: (expr) ->
    return ((new lisp_channel(expr).read @environment).evaluate @environment).prin1()
    
  initialize: ->
    @variables = new namespace()
    @functions = new namespace()
    @environment = {
      'variables': @variables,
      'functions': @functions,
      'files': {},
      'oblist': {},}
      
    toploop = \
    '''(errorset
      '(prog (expr result)
      loop
        (setq expr (read))
        (cond ((equal expr $EOF$) (return NIL))
              (T (progn (setq result (eval expr))
                        (cond (*OUTPUT
                               (progn
                                (terpri)
                                (prin2 "Value: ")
                                (prin1 result)))))))
        (go loop))
      T NIL)'''
      
      
    @toploop = new lisp_channel(toploop).read @environment

    @variables.set 'STDIN*', @stdin, true
    @variables.set 'STDOUT*', @stdout, true
    @variables.set 'STDERR*', @stderr, true
    @variables.set 'IN*', @stdin
    @variables.set 'OUT*', @stdout
    @variables.set 'ERROUT*', @stderr

    @variables.set 'NIL', NIL, true
    @variables.set 'T', T, true
    @variables.set '$EOF$', EOF, true
    @variables.set 'EMSG*', NIL
    @variables.set '*RAISE', NIL
    @variables.set '*GSNUM', new lisp_integer 1
    @variables.set '*OUTPUT', T
    
    for func of builtins
      @functions.set func, builtins[func], true
    
    for func of interpreted_builtins
      @evaluate_string interpreted_builtins[func]
      @functions.get(func).constant = true

`#if !defined(node)
`
# roughly from coffeescript's browser.coffee
runScripts = ->
  scripts = (s for s in document.getElementsByTagName 'script' when s.type is 'text/substandard-lisp')
  if scripts.length isnt 0
    window.lisp = new interpreter()
    lisp.initialize()

  for s in scripts
    lisp.evaluate s.innerHTML

if window.addEventListener
  addEventListener 'DOMContentLoaded', runScripts, no
else
  attachEvent 'onload', runScripts
`#endif
`
